home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / akcl / kcl.lha / lsp / predlib.lsp < prev    next >
Lisp/Scheme  |  1987-06-04  |  18KB  |  508 lines
  1. ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  2. ;; Copying of this file is authorized to users who have executed the true and
  3. ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  4.  
  5. ;;;;    predlib.lsp
  6. ;;;;
  7. ;;;;                              predicate routines
  8.  
  9.  
  10. (in-package 'lisp)
  11. (export '(deftype typep subtypep coerce))
  12.  
  13.  
  14. (in-package 'system)
  15.  
  16.  
  17. (proclaim '(optimize (safety 2) (space 3)))
  18.  
  19.  
  20. ;;; DEFTYPE macro.
  21. (defmacro deftype (name lambda-list &rest body)
  22.   ;; Replace undefaultized optional parameter X by (X '*).
  23.   (do ((l lambda-list (cdr l))
  24.        (m nil (cons (car l) m)))
  25.       ((null l))
  26.     (when (member (car l) lambda-list-keywords)
  27.       (unless (eq (car l) '&optional) (return nil))
  28.       (setq m (cons '&optional m))
  29.       (setq l (cdr l))
  30.       (do ()
  31.           ((or (null l) (member (car l) lambda-list-keywords)))
  32.         (if (symbolp (car l))
  33.         (setq m (cons (list (car l) ''*) m))
  34.         (setq m (cons (car l) m)))
  35.         (setq l (cdr l)))
  36.       (setq lambda-list (nreconc m l))
  37.       (return nil)))
  38.   `(progn (si:putprop ',name
  39.                       '(deftype ,name ,lambda-list ,@body)
  40.                       'deftype-form)
  41.           (si:putprop ',name
  42.               #'(lambda ,lambda-list ,@body)
  43.               'deftype-definition)
  44.           (si:putprop ',name
  45.                       ,(find-documentation body)
  46.                       'type-documentation)
  47.           ',name))
  48.  
  49.  
  50. ;;; Some DEFTYPE definitions.
  51. (deftype fixnum ()
  52.   `(integer ,most-negative-fixnum ,most-positive-fixnum))
  53. (deftype bit () '(integer 0 1))
  54. (deftype mod (n)
  55.   `(integer 0 ,(1- n)))
  56. (deftype signed-byte (&optional s)
  57.   (if (eq s '*)
  58.       `(integer * *)
  59.       `(integer ,(- (expt 2 (1- s))) ,(1- (expt 2 (1- s))))))
  60. (deftype unsigned-byte (&optional s)
  61.   (if (eq s '*)
  62.       `(integer 0 *)
  63.       `(integer 0 ,(1- (expt 2 s)))))
  64.  
  65. (deftype vector (&optional element-type size)
  66.   `(array ,element-type (,size)))
  67. (deftype string (&optional size)
  68.   `(vector string-char ,size))
  69. (deftype bit-vector (&optional size)
  70.   `(vector bit ,size))
  71.  
  72. (deftype simple-vector (&optional size)
  73.   `(simple-array t (,size)))
  74. (deftype simple-string (&optional size)
  75.   `(simple-array string-char (,size)))
  76. (deftype simple-bit-vector (&optional size)
  77.   `(simple-array bit (,size)))
  78.  
  79.  
  80.  
  81. (defun simple-array-p (x)
  82.   (and (arrayp x)
  83.        (not (adjustable-array-p x))
  84.        (not (array-has-fill-pointer-p x))
  85.        (not (si:displaced-array-p x))))
  86.  
  87.  
  88. (do ((l '((null . null)
  89.           (symbol . symbolp)
  90.           (keyword . keywordp)
  91.           (atom . atom)
  92.           (cons . consp)
  93.           (list . listp)
  94.           (number . numberp)
  95.           (character . characterp)
  96.           (package . packagep)
  97.           (stream . streamp)
  98.           (pathname . pathnamep)
  99.           (readtable . readtablep)
  100.           (hash-table . hash-table-p)
  101.           (random-state . random-state-p)
  102.           (structure . si:structurep)
  103.           (function . functionp)
  104.           (compiled-function . compiled-function-p)
  105.           (common . commonp)
  106.           )
  107.         (cdr l)))
  108.     ((endp l))
  109.   (si:putprop (caar l) (cdar l) 'type-predicate))
  110.  
  111.  
  112. ;;; TYPEP predicate.
  113. (defun typep (object type &aux tp i)
  114.   (if (atom type)
  115.       (setq tp type i nil)
  116.       (setq tp (car type) i (cdr type)))
  117.   (let ((f (get tp 'type-predicate)))
  118.     (when f (return-from typep (funcall f object))))
  119.   (case tp
  120.     (member (member object i))
  121.     (not (not (typep object (car i))))
  122.     (or
  123.      (do ((l i (cdr l)))
  124.          ((null l) nil)
  125.       (when (typep object (car l)) (return t))))
  126.     (and
  127.      (do ((l i (cdr l)))
  128.          ((null l) t)
  129.        (unless (typep object (car l)) (return nil))))
  130.     (satisfies (funcall (car i) object))
  131.     ((t) t)
  132.     ((nil) nil)
  133.     (fixnum (eq (type-of object) 'fixnum))
  134.     (bignum (eq (type-of object) 'bignum))
  135.     (ratio (eq (type-of object) 'ratio))
  136.     (standard-char
  137.      (and (characterp object) (standard-char-p object)))
  138.     (string-char
  139.      (and (characterp object) (string-char-p object)))
  140.     (integer
  141.      (and (integerp object) (in-interval-p object i)))
  142.     (rational
  143.      (and (rationalp object) (in-interval-p object i)))
  144.     (float
  145.      (and (floatp object) (in-interval-p object i)))
  146.     ((short-float)
  147.      (and (eq (type-of object) 'short-float) (in-interval-p object i)))
  148.     ((single-float double-float long-float)
  149.      (and (eq (type-of object) 'long-float) (in-interval-p object i)))
  150.     (complex
  151.      (and (complexp object)
  152.           (typep (realpart object) (car i))
  153.           (typep (imagpart object) (car i))))
  154.     (sequence (or (listp object) (vectorp object)))
  155.     (string
  156.      (and (stringp object)
  157.           (or (null i) (match-dimensions (array-dimensions object) i))))
  158.     (bit-vector
  159.      (and (bit-vector-p object)
  160.           (or (null i) (match-dimensions (array-dimensions object) i))))
  161.     (simple-string
  162.      (and (simple-string-p object)
  163.           (or (null i) (match-dimensions (array-dimensions object) i))))
  164.     (simple-bit-vector
  165.      (and (simple-bit-vector-p object)
  166.           (or (null i) (match-dimensions (array-dimensions object) i))))
  167.     (simple-vector
  168.      (and (simple-vector-p object)
  169.           (or (null i) (match-dimensions (array-dimensions object) i))))
  170.     (simple-array
  171.      (and (simple-array-p object)
  172.           (or (endp i) (eq (car i) '*)
  173.               (equal (array-element-type object) (car i)))
  174.           (or (endp (cdr i)) (eq (cadr i) '*)
  175.               (match-dimensions (array-dimensions object) (cadr i)))))
  176.     (array
  177.      (and (arrayp object)
  178.           (or (endp i) (eq (car i) '*)
  179.               ;; Or the element type of object should be EQUAL to (car i).
  180.               ;; Is this too strict?
  181.               (equal (array-element-type object) (car i)))
  182.           (or (endp (cdr i)) (eq (cadr i) '*)
  183.               (match-dimensions (array-dimensions object) (cadr i)))))
  184.     (t
  185.      (cond ((get tp 'is-a-structure)
  186.             (if (si:structurep object)
  187.                 ;; Follow the chain of structure-include.
  188.                 (do ((stp (si:structure-name object)
  189.                           (get stp 'structure-include)))
  190.                     ((eq tp stp) t)
  191.                   (when (null (get stp 'structure-include))
  192.                         (return nil)))
  193.                 nil))
  194.            ((get tp 'deftype-definition)
  195.             (typep object
  196.                    (apply (get tp 'deftype-definition) i)))))))
  197.  
  198.  
  199. ;;; NORMALIZE-TYPE normalizes the type using the DEFTYPE definitions.
  200. ;;; The result is always a list.
  201. (defun normalize-type (type &aux tp i)
  202.   ;; Loops until the car of type has no DEFTYPE definition.
  203.   (loop
  204.     (if (atom type)
  205.         (setq tp type i nil)
  206.         (setq tp (car type) i (cdr type)))
  207.     (if (get tp 'deftype-definition)
  208.         (setq type (apply (get tp 'deftype-definition) i))
  209.         (return-from normalize-type (if (atom type) (list type) type)))))
  210.  
  211.  
  212. ;;; KNOWN-TYPE-P answers if the given type is a known base type.
  213. ;;; The type may not be normalized.
  214. (defun known-type-p (type)
  215.   (when (consp type) (setq type (car type)))
  216.   (if (or (member type
  217.                   '(t nil null symbol keyword atom cons list sequence
  218.                     number integer bignum rational ratio float
  219.                     short-float single-float double-float long-float complex
  220.                     character standard-char string-char
  221.                     package stream pathname readtable hash-table random-state
  222.                     structure array simple-array function compiled-function))
  223.           (get type 'is-a-structure))
  224.       t
  225.       nil))
  226.  
  227.  
  228. ;;; SUBTYPEP predicate.
  229. (defun subtypep (type1 type2 &aux t1 t2 i1 i2 ntp1 ntp2)
  230.   (setq type1 (normalize-type type1))
  231.   (setq type2 (normalize-type type2))  
  232.   (when (equal type1 type2)
  233.     (return-from subtypep (values t t)))
  234.   (setq t1 (car type1) t2 (car type2))
  235.   (setq i1 (cdr type1) i2 (cdr type2))
  236.   (cond ((eq t1 'member)
  237.          (dolist (e i1)
  238.            (unless (typep e type2) (return-from subtypep (values nil t))))
  239.          (return-from subtypep (values t t)))
  240.         ((eq t1 'or)
  241.          (dolist (tt i1)
  242.            (multiple-value-bind (tv flag) (subtypep tt type2)
  243.              (unless tv (return-from subtypep (values tv flag)))))
  244.          (return-from subtypep (values t t)))
  245.         ((eq t1 'and)
  246.          (dolist (tt i1)
  247.            (let ((tv (subtypep tt type2)))
  248.              (when tv (return-from subtypep (values t t)))))
  249.          (return-from subtypep (values nil nil)))
  250.         ((eq t1 'not)
  251.          (multiple-value-bind (tv flag) (subtypep (car i1) type2)
  252.            (return-from subtypep (values (not tv) flag)))))
  253.   (cond ((eq t2 'member)
  254.          (return-from subtypep (values nil nil)))
  255.         ((eq t2 'or)
  256.          (dolist (tt i2)
  257.            (let ((tv (subtypep type1 tt)))
  258.              (when tv (return-from subtypep (values t t)))))
  259.          (return-from subtypep (values nil nil)))
  260.         ((eq t2 'and)
  261.          (dolist (tt i2)
  262.            (multiple-value-bind (tv flag) (subtypep type1 tt)
  263.              (unless tv (return-from subtypep (values tv flag)))))
  264.          (return-from subtypep (values nil nil)))
  265.         ((eq t2 'not)
  266.          (multiple-value-bind (tv flag) (subtype type1 (car i2))
  267.            (return-from subtypep (values (not tv) flag)))))
  268.   (setq ntp1 (known-type-p type1) ntp2 (known-type-p type2))
  269.   (cond    ((or (eq t1 'nil) (eq t2 't) (eq t2 'common)) (values t t))
  270.            ((eq t2 'nil) (values nil ntp1))
  271.            ((eq t1 't) (values nil ntp2))
  272.            ((eq t1 'common) (values nil ntp2))
  273.            ((eq t2 'list)
  274.             (cond ((member t1 '(null cons list)) (values t t))
  275.                   (t (values nil ntp1))))
  276.            ((eq t2 'sequence)
  277.             (cond ((member t1 '(null cons list sequence)) (values t t))
  278.                   ((eq t1 'array)
  279.                    (if (and (cdr i1) (consp (cadr i1)) (null (cdadr i1)))
  280.                        (values t t)
  281.                        (values nil t)))
  282.                   (t (values nil ntp1))))
  283.            ((eq t1 'list) (values nil ntp2))
  284.            ((eq t1 'sequence) (values nil ntp2))
  285.            ((eq t2 'atom)
  286.             (cond ((member t1 '(cons list)) (values nil t))
  287.                   (ntp1 (values t t))
  288.                   (t (values nil nil))))
  289.            ((eq t1 'atom) (values nil ntp2))
  290.            ((eq t2 'symbol)
  291.             (if (member t1 '(symbol keyword null))
  292.                 (values t t)
  293.                 (values nil ntp1)))
  294.            ((eq t2 'keyword)
  295.             (if (eq t1 'keyword) (values t t) (values nil ntp1)))
  296.            ((eq t2 'null)
  297.             (if (eq t1 'null) (values t t) (values nil ntp1)))
  298.            ((eq t2 'number)
  299.      (cond ((member t1 '(bignum integer ratio rational float
  300.                          short-float single-float double-float long-float
  301.                          complex number))
  302.             (values t t))
  303.            (t (values nil ntp1))))
  304.            ((eq t1 'number) (values nil ntp2))
  305.            ((eq t2 'structure)
  306.             (if (or (eq t1 'structure) (get t1 'is-a-structure))
  307.                 (values t t)
  308.                 (values nil ntp1)))
  309.            ((eq t1 'structure) (values nil ntp2))
  310.            ((get t1 'is-a-structure)
  311.             (if (get t2 'is-a-structure)
  312.                 (do ((tp1 t1 (get tp1 'structure-include)) (tp2 t2))
  313.                     ((null tp1) (values nil t))
  314.                   (when (eq tp1 tp2) (return (values t t))))
  315.                 (values nil ntp2)))
  316.            ((get t2 'is-a-structure) (values nil ntp1))
  317.            (t
  318.             (case t1
  319.               (bignum
  320.                (case t2
  321.                  (bignum (values t t))
  322.                  ((integer rational)
  323.                   (if (sub-interval-p '(* *) i2)
  324.                       (values t t)
  325.                       (values nil t)))
  326.                  (t (values nil ntp2))))
  327.               (ratio
  328.                (case t2
  329.                  (ratio (values t t))
  330.                  (rational
  331.                   (if (sub-interval-p '(* *) i2) (values t t) (values nil t)))
  332.                  (t (values nil ntp2))))
  333.               (standard-char
  334.         (if (member t2 '(standard-char string-char character))
  335.             (values t t)
  336.             (values nil ntp2)))
  337.        (standard-char
  338.         (if (member t2 '(string-char character))
  339.             (values t t)
  340.             (values nil ntp2)))
  341.        (integer
  342.         (if (member t2 '(integer rational))
  343.         (values (sub-interval-p i1 i2) t)
  344.         (values nil ntp2)))
  345.        (rational
  346.         (if (member t2 'rational)
  347.         (values (sub-interval-p i1 i2) t)
  348.         (values nil ntp2)))
  349.        (float
  350.         (if (eq t2 'float)
  351.         (values (sub-interval-p i1 i2) t)
  352.         (values nil ntp2)))
  353.        ((short-float)
  354.         (if (member t2 '(short-float float))
  355.         (values (sub-interval-p i1 i2) t)
  356.         (values nil ntp2)))
  357.        ((single-float double-float long-float)
  358.         (if (member t2 '(single-float double-float long-float float))
  359.         (values (sub-interval-p i1 i2) t)
  360.         (values nil ntp2)))
  361.        (complex
  362.         (if (eq t2 'complex)
  363.             (multiple-value-bind (x y) (subtypep (car i1) (car i2))
  364.               (values x y))
  365.             (values nil ntp2)))
  366.        (simple-array
  367.         (cond ((or (eq t2 'simple-array) (eq t2 'array))
  368.                (if (or (endp i1) (eq (car i1) '*))
  369.                    (unless (or (endp i2) (eq (car i2) '*))
  370.                            (return-from subtypep (values nil t)))
  371.                    (unless (or (endp i2) (eq (car i2) '*))
  372.                            (unless (equal (car i1) (car i2))
  373.                                    ;; Unless the element type matches,
  374.                                    ;;  return NIL T.
  375.                                    ;; Is this too strict?
  376.                                    (return-from subtypep
  377.                                                 (values nil t)))))
  378.                (when (or (endp (cdr i1)) (eq (cadr i1) '*))
  379.                  (if (or (endp (cdr i2)) (eq (cadr i2) '*))
  380.                      (return-from subtypep (values t t))
  381.                      (return-from subtypep (values nil t))))
  382.            (when (or (endp (cdr i2)) (eq (cadr i2) '*))
  383.                  (return-from subtypep (values t t)))
  384.            (values (match-dimensions (cadr i1) (cadr i2)) t))
  385.               (t (values nil ntp2))))
  386.        (array
  387.         (cond ((eq t2 'array)
  388.                (if (or (endp i1) (eq (car i1) '*))
  389.                    (unless (or (endp i2) (eq (car i2) '*))
  390.                            (return-from subtypep (values nil t)))
  391.                    (unless (or (endp i2) (eq (car i2) '*))
  392.                            (unless (equal (car i1) (car i2))
  393.                                    (return-from subtypep
  394.                                                 (values nil t)))))
  395.                (when (or (endp (cdr i1)) (eq (cadr i1) '*))
  396.                  (if (or (endp (cdr i2)) (eq (cadr i2) '*))
  397.                      (return-from subtypep (values t t))
  398.                      (return-from subtypep (values nil t))))
  399.            (when (or (endp (cdr i2)) (eq (cadr i2) '*))
  400.                  (return-from subtypep (values t t)))
  401.            (values (match-dimensions (cadr i1) (cadr i2)) t))
  402.               (t (values nil ntp2))))
  403.        (t (if ntp1 (values (eq t1 t2) t) (values nil nil)))))))
  404.  
  405.  
  406. (defun sub-interval-p (i1 i2)
  407.   (let (low1 high1 low2 high2)
  408.     (if (endp i1)
  409.         (setq low1 '* high1 '*)
  410.         (if (endp (cdr i1))
  411.             (setq low1 (car i1) high1 '*)
  412.             (setq low1 (car i1) high1 (cadr i1))))
  413.     (if (endp i2)
  414.         (setq low2 '* high2 '*)
  415.         (if (endp (cdr i2))
  416.             (setq low2 (car i2) high2 '*)
  417.             (setq low2 (car i2) high2 (cadr i2))))
  418.     (cond ((eq low1 '*)
  419.        (unless (eq low2 '*)
  420.                (return-from sub-interval-p nil)))
  421.           ((eq low2 '*))
  422.       ((consp low1)
  423.        (if (consp low2)
  424.            (when (< (car low1) (car low2))
  425.              (return-from sub-interval-p nil))
  426.            (when (< (car low1) low2)
  427.              (return-from sub-interval-p nil))))
  428.       ((if (consp low2)
  429.            (when (<= low1 (car low2))
  430.              (return-from sub-interval-p nil))
  431.            (when (< low1 low2)
  432.              (return-from sub-interval-p nil)))))
  433.     (cond ((eq high1 '*)
  434.        (unless (eq high2 '*)
  435.                (return-from sub-interval-p nil)))
  436.           ((eq high2 '*))
  437.       ((consp high1)
  438.        (if (consp high2)
  439.            (when (> (car high1) (car high2))
  440.              (return-from sub-interval-p nil))
  441.            (when (> (car high1) high2)
  442.              (return-from sub-interval-p nil))))
  443.       ((if (consp high2)
  444.            (when (>= high1 (car high2))
  445.              (return-from sub-interval-p nil))
  446.            (when (> high1 high2)
  447.              (return-from sub-interval-p nil)))))
  448.     (return-from sub-interval-p t)))
  449.  
  450. (defun in-interval-p (x interval)
  451.   (let (low high)
  452.     (if (endp interval)
  453.         (setq low '* high '*)
  454.         (if (endp (cdr interval))
  455.             (setq low (car interval) high '*)
  456.             (setq low (car interval) high (cadr interval))))
  457.     (cond ((eq low '*))
  458.           ((consp low)
  459.            (when (<= x (car low)) (return-from in-interval-p nil)))
  460.           ((when (< x low) (return-from in-interval-p nil))))
  461.     (cond ((eq high '*))
  462.           ((consp high)
  463.            (when (>= x (car high)) (return-from in-interval-p nil)))
  464.           ((when (> x high) (return-from in-interval-p nil))))
  465.     (return-from in-interval-p t)))
  466.  
  467. (defun match-dimensions (dim pat)
  468.   (if (null dim)
  469.       (null pat)
  470.       (and (or (eq (car pat) '*)
  471.            (eq (car dim) (car pat)))
  472.        (match-dimensions (cdr dim) (cdr pat)))))
  473.  
  474.  
  475.  
  476. ;;; COERCE function.
  477. (defun coerce (object type)
  478.   (when (typep object type)
  479.         ;; Just return as it is.
  480.         (return-from coerce object))
  481.   (setq type (normalize-type type))
  482.   (case (car type)
  483.     (list
  484.      (do ((l nil (cons (elt object i) l))
  485.           (i (1- (length object)) (1- i)))
  486.          ((< i 0) l)))
  487.     ((array simple-array)
  488.      (unless (or (endp (cdr type))
  489.                  (endp (cddr type))
  490.                  (eq (caddr type) '*)
  491.                  (endp (cdr (caddr type))))
  492.              (error "Cannot coerce to an multi-dimensional array."))
  493.      (do ((seq (make-sequence type (length object)))
  494.           (i 0 (1+ i))
  495.           (l (length object)))
  496.          ((>= i l) seq)
  497.        (setf (elt seq i) (elt object i))))
  498.     (character (character object))
  499.     (float (float object))
  500.     ((short-float) (float object 0.0S0))
  501.     ((single-float double-float long-float) (float object 0.0L0))
  502.     (complex
  503.      (if (or (null (cdr type)) (null (cadr type)) (eq (cadr type) '*))
  504.          (complex (realpart object) (imagpart object))
  505.          (complex (coerce (realpart object) (cadr type))
  506.                   (coerce (imagpart object) (cadr type)))))
  507.     (t (error "Cannot coerce ~S to ~S." object type))))
  508.